(*
  Copyright (c) 2009 Barry Schwartz

  Permission is hereby granted, free of charge, to any person
  obtaining a copy of this software and associated documentation
  files (the "Software"), to deal in the Software without
  restriction, including without limitation the rights to use,
  copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the
  Software is furnished to do so, subject to the following
  conditions:

  The above copyright notice and this permission notice shall be
  included in all copies or substantial portions of the Software.

  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
  OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
  OTHER DEALINGS IN THE SOFTWARE.
*)

(*-----------------------------------------------------------------------*)

open FontForge
open FontMetric
open GlyphMetric
open Pycaml
open Python_tools
open Substitute
open UniTools
open XNum
  
(*-----------------------------------------------------------------------*)

module LigKern =
struct
  type lig_kern_cmd =
    | LigCmd of int * int * int * int | KernCmd of int * int * num
        
  (* access methods *)
  let is_lig lk =
    match lk with
      | LigCmd (_, _, _, _) -> true
      | KernCmd (_, _, _) -> false
          
  let is_kern lk =
    match lk with
      | LigCmd (_, _, _, _) -> false
      | KernCmd (_, _, _) -> true
          
  let skip lk =
    match lk with | LigCmd (s, _, _, _) -> s | KernCmd (s, _, _) -> s
      
  let next lk =
    match lk with | LigCmd (_, n, _, _) -> n | KernCmd (_, n, _) -> n
      
  let operand lk =
    match lk with
      | LigCmd (_, _, o, _) -> o
      | KernCmd (_, _, _) ->
          raise (Invalid_argument "LigKern.operand applied to kern!")
            
  let remainder lk =
    match lk with
      | LigCmd (_, _, _, r) -> r
      | KernCmd (_, _, _) ->
          raise (Invalid_argument "LigKern.remainder applied to kern!")
            
  let kern lk =
    match lk with
      | LigCmd (_, _, _, _) ->
          raise (Invalid_argument "LigKern.kern applied to ligature!")
      | KernCmd (_, _, k) -> k
          
  (* |next_lig_kern| can be used to enumerate all lig-kern pairs. *)
  let next_lig_kern lk_array pos =
    let lk = lk_array.(pos) in
    let s = skip lk in
    let n = next lk in
    let next_pos = if s < 128 then (pos + s) + 1 else (-1)
    in
      if s <= 128
      then
        if is_lig lk
        then
          (let op = operand lk
           in
             (next_pos, n,
              (GlyphMetric.Ligature (remainder lk, op lsr 2,
                                     ((op lsr 1) land 1) = 1, (op land 1) = 1))))
        else (next_pos, n, (GlyphMetric.Kern (kern lk)))
      else ((-1), (-1), NoLigKern)
        
  (*
    Determines the ligature or kerning of two characters. lk_array is the array of LigKern commands,
    pos the position corresponding to the current character, and next_char the next character.
  *)
  let rec get_lig_kern lk_array pos next_char =
    let lk = lk_array.(pos) in
    let s = skip lk in
    let n = next lk in
      if n = next_char && s <= 128 then
        if is_lig lk then
          let op = operand lk in
            GlyphMetric.Ligature (remainder lk, op lsr 2, ((op lsr 1) land 1) = 1, (op land 1) = 1)
        else
          GlyphMetric.Kern (kern lk)
      else if s < 128 then
        get_lig_kern lk_array ((pos + s) + 1) next_char
      else
        NoLigKern
          
  let rec list_lig_kerns lk_array pos =
    let lk = lk_array.(pos) in
    let s = skip lk in
    let n = next lk in
      if s > 128 then
        []
      else if is_lig lk then
        let op = operand lk in
        let
            l = (n, (GlyphMetric.Ligature (remainder lk,
                                           op lsr 2,
                                           ((op lsr 1) land 1) = 1,
                                           (op land 1) = 1)))
        in
          if s < 128 then
            l :: (list_lig_kerns lk_array ((pos + s) + 1))
          else
            [l]
      else
        let k = (n, (GlyphMetric.Kern (kern lk))) in
          if s < 128 then
            k :: (list_lig_kerns lk_array ((pos + s) + 1))
          else
            [k]
end
  
(*-----------------------------------------------------------------------*)

let num_0x100 = num_of_int 0x100
let num_0x10000 = num_of_int 0x10000
let num_0x100000 = num_of_int 0x100000
let num_0x1000000 = num_of_int 0x1000000
  
let read_fix ic = div_num (IO.read_be_i32 ic) num_0x100000
  
let read_4 ic =
  let x1 = IO.read_be_u8 ic in
  let x2 = IO.read_be_u8 ic in
  let x3 = IO.read_be_u8 ic in let x4 = IO.read_be_u8 ic in (x1, x2, x3, x4)
  
let read_array ic read_fun len =
  if len <= 0 then
    [|  |]
  else
    let a = Array.make len (read_fun ic) in
      for i = 1 to len - 1 do
        a.(i) <- read_fun ic
      done;
      a
  
let tfm_kerning lig_kern font c1 c2 =
  match (get_glyph_metric font (Simple c1)).gm_extra with
    | GXI_LigKern lk -> LigKern.get_lig_kern lig_kern lk c2
    | _ -> NoLigKern
  
let get_glyph_bitmap bitmaps fm code =
  (if !bitmaps = None
   then
     (match FontPK.read_pk_font fm !default_bitmap_resolution with
        | None -> ()
        | Some ((_, gs)) -> bitmaps := Some gs)
   else ();
   match !bitmaps with
     | None -> GlyphBitmap.empty_glyph
     | Some bm -> bm.(code - fm.first_glyph))
  
let make_lig_kern kern (x1, x2, x3, x4) =
  if x3 < 128 then
    LigKern.LigCmd (x1, x2, x3, x4)
  else
    LigKern.KernCmd (x1, x2, kern.((0x100 * (x3 - 128)) + x4))
  
let make_glyph_metric glyph_idx letter_spacing extra_kern size width height
    depth italic lig exten (w, x1, x2, r) =
  let h = x1 lsr 4 in
  let d = x1 land 0xf in
  let i = x2 lsr 2 in
  let t = x2 land 0x3 in
  let user_kern_info =
    try
      let ki = List.assoc glyph_idx extra_kern in
        { ki_after_space = mult_num size ki.ki_after_space;
          ki_before_space = mult_num size ki.ki_before_space;
          ki_after_margin = mult_num size ki.ki_after_margin;
          ki_before_margin = mult_num size ki.ki_before_margin;
          ki_after_foreign = mult_num size ki.ki_after_foreign;
          ki_before_foreign = mult_num size ki.ki_before_foreign }
    with | Not_found -> zero_kern_info in
    (* If italic.(i) = 0 then we do not need to allocate a new structure. *)
  let kern_info =
    if not (eq_num italic.(i) num_zero) then
      { user_kern_info with
          ki_before_foreign = add_num italic.(i) user_kern_info.ki_before_foreign }
    else user_kern_info in
  let extra =
    match t with
      | 0 -> GXI_Normal
      | 1 ->
          let lk = lig.(r) in
            GXI_LigKern
              (if (LigKern.is_lig lk) && ((LigKern.skip lk) > 128)
               then (256 * (LigKern.operand lk)) + (LigKern.remainder lk)
               else r)
      | 2 -> GXI_List r
      | _ -> let (t, m, b, r) = exten.(r) in GXI_Extendable (t, m, b, r)
  in
    { gm_width = add_num width.(w) (mult_num (mult_num num_two size) letter_spacing);
      gm_height = height.(h);
      gm_depth = depth.(d);
      gm_italic = italic.(i);
      gm_extra = extra;
      gm_extra_kern = kern_info }
  
(*-----------------------------------------------------------------------*)

let get_encoding_and_font_name tfm_font_name =
  let kt_tfm = py_module "kt.tfm" in
  let args = pytuple_fromsingle (pythonize_string tfm_font_name) in
  let tuple = py_module_call kt_tfm "get_encoding_and_font_name" args in
    unpythonize_string_tuple tuple

let unpythonize_encoding_file_data =
  unpythonizing_function
    ~expect_tuple:true
    [| EitherStringType; ListType |]
    (fun py_args ->
       let encoding_name = unpythonize_string py_args.(0) in
       let glyph_names = unpythonize_list unpythonize_string py_args.(1) in
         (encoding_name, glyph_names))

let read_encoding_file file_name =
  let kt_tfm = py_module "kt.tfm" in
  let args = pytuple_fromsingle (pythonize_string file_name) in
  let tuple = py_module_call kt_tfm "read_encoding_file" args in
    unpythonize_encoding_file_data tuple

let read_encoding enc_name =
  if enc_name = "" then
    ("", [])
  else
    let file_name =
      try
        KPathSea.find_resource ~format:KPathSea.kpse_enc_format enc_name
      with
        | Not_found -> ""
    in
      if file_name = "" then
        ("", [])
      else
        read_encoding_file file_name

let get_builtin_encoding ff_font =
  let rec grow_by_one_glyph (p, p_len) (glyph_code, glyph_name) =
    if p_len < glyph_code then
      grow_by_one_glyph (".notdef" :: p, p_len + 1) (glyph_code, glyph_name)
    else
      (glyph_name :: p, p_len + 1)
  in
  let extract_glyph_data glyph =
    let glyph_code = FFglyph.glyph_enc glyph in
    let glyph_name = FFglyph.glyph_str glyph in
      (glyph_code, glyph_name)
  in
  let glyphs = FFfont.glyphs ~encoding_order:true ff_font in
  let grow_by_one list_data glyph =
    grow_by_one_glyph list_data (extract_glyph_data glyph)
  in
  let (names, _) = Array.fold_left grow_by_one ([], 0) glyphs in
    Array.of_list (List.rev names)

let read_tfm ff_font file name params =
  let (enc_name, font_name) = get_encoding_and_font_name name in
  let font_file = UniText.of_string (KPathSea.find_resource ~format:KPathSea.kpse_type1_format font_name) in
  let (_encoding_name, encoding_order) =
    if enc_name = "" then
      ("", get_builtin_encoding ff_font)
    else
      let (name, order) = read_encoding enc_name in
        (name, Array.of_list order)
  in
  let ic = IO.make_in_stream file in
  let _file_length = IO.read_be_u16 ic in
  let header_length = IO.read_be_u16 ic in
  let first_glyph = IO.read_be_u16 ic in
  let last_glyph = IO.read_be_u16 ic in
  let glyph_metric_table_len = (last_glyph - first_glyph) + 1 in
  let width_table_len = IO.read_be_u16 ic in
  let height_table_len = IO.read_be_u16 ic in
  let depth_table_len = IO.read_be_u16 ic in
  let italic_table_len = IO.read_be_u16 ic in
  let lig_table_len = IO.read_be_u16 ic in
  let kern_table_len = IO.read_be_u16 ic in
  let ext_table_len = IO.read_be_u16 ic in
  let param_table_len = IO.read_be_u16 ic in
  let check_sum = IO.read_be_u32 ic in
  let design_size = read_fix ic in
  let size =
    if ge_num params.flp_size num_zero then
      params.flp_size
    else
      design_size
  in
  let () = IO.skip ic ((4 * header_length) - 8) in
  let glyph_metric = read_array ic read_4 glyph_metric_table_len in
  let width = Array.map (fun x -> mult_num x size) (read_array ic read_fix width_table_len) in
  let height = Array.map (fun x -> mult_num x size) (read_array ic read_fix height_table_len) in
  let depth = Array.map (fun x -> mult_num x size) (read_array ic read_fix depth_table_len) in
  let italic = Array.map (fun x -> mult_num x size) (read_array ic read_fix italic_table_len) in
  let lig = read_array ic read_4 lig_table_len in
  let kern = Array.map (fun x -> mult_num x size) (read_array ic read_fix kern_table_len) in
  let ext = read_array ic read_4 ext_table_len in
  let param = read_array ic read_fix param_table_len in
  let lig_cmds = Array.map (fun x -> make_lig_kern kern x) lig in
  let (enc, dec) =
    match params.flp_encoding with
      | [|  |] ->
          let order = Array.map UString.glyph_name_to_uc_string encoding_order in
            (Encodings.charmap_encoding (Encodings.fake_encoding order),
             Encodings.array_decoding order)
      | m ->
          (Encodings.charmap_encoding (Encodings.fake_encoding m),
           Encodings.array_decoding m)
  in
  let lookup_char x =
    match enc x with
      | Simple g -> g
      | _ -> (-1)
  in
  let lookup_name _x = (-1) in          (* FIX *)
  let extra_kern =
    List.map
      (fun (g, k) -> ((glyph_spec_to_index lookup_char lookup_name g), k))
      params.flp_extra_kern
  in
  let gm_table =
    Array.mapi
      (fun i gm ->
         make_glyph_metric (i + first_glyph) params.flp_letter_spacing
           extra_kern size width height depth italic lig_cmds ext gm)
      glyph_metric
  in
  let hyphen_glyph =
    match params.flp_hyphen_glyph with
      | Undef -> Simple 45
      | h -> h
  in
  let get_glyph_name g =
    try
      encoding_order.(g)
    with
      | Invalid_argument _ ->
          raise Not_found
  in
  let get_code name = (* FIX: Maybe make this faster (probably not important, though). *)
    let rec test i =
      if i = last_glyph + 1 then
        raise Not_found
      else if encoding_order.(i) = name then
        i
      else
        test (i + 1)
    in
      test first_glyph
  in
  let gid_lookup =
    let get_gid i =
      let glyph_name = get_glyph_name (first_glyph + i) in
        try
          FFglyph.originalgid (FFfont.str_glyph ff_font glyph_name)
        with
            Not_found -> 0
    in
      Array.init (last_glyph - first_glyph + 1) get_gid
  in
    { id = new_fontmetric_id ();
      name = name;
      ps_name = name;
      file_name = font_file;
      font_type = TFM;
      first_glyph = first_glyph;
      last_glyph = last_glyph;
      glyph_metric = gm_table;
      design_size = design_size;
      at_size = size;
      check_sum = check_sum;
      get_glyph = enc;
      get_unicode = dec;
      draw_simple_glyph =
        if eq_num params.flp_letter_spacing num_zero then
          draw_simple_glyph
        else
          draw_displaced_simple_glyph (mult_num size params.flp_letter_spacing) num_zero;
      accent_base_point = accent_base_point_x_height;
      accent_attach_point = accent_attach_point_top;
      get_composer = (fun _ _ -> failwith "Module FontTFM no longer supports composers.");
      kerning = tfm_kerning lig_cmds;
      get_glyph_bitmap = get_glyph_bitmap (ref None);
      get_glyph_name = get_glyph_name;
      get_glyph_index = (fun name -> FFglyph.originalgid (FFfont.str_glyph ff_font name));
      code_to_glyph_index = (fun c -> gid_lookup.(c - first_glyph));
      glyph_name_to_code = get_code;
      parameter =
        { hyphen_glyph = hyphen_glyph;
          skew_glyph = params.flp_skew_glyph;
          margin_glyph = Simple (last_glyph + 1);
          space_glyph = Simple (last_glyph + 2);
          foreign_glyph = Simple (last_glyph + 3);
          slant = if param_table_len > 0 then param.(0) else num_zero;
          space = if param_table_len > 1 then mult_num size param.(1) else num_zero;
          space_stretch = if param_table_len > 2 then mult_num size param.(2) else num_zero;
          space_shrink = if param_table_len > 3 then mult_num size param.(3) else num_zero;
          x_height = if param_table_len > 4 then mult_num size param.(4) else num_zero;
          quad = if param_table_len > 5 then mult_num size param.(5) else design_size;
          extra_space = if param_table_len > 6 then mult_num size param.(6) else num_zero;
          num_shift_1 = if param_table_len > 7 then mult_num size param.(7) else num_zero;
          num_shift_2 = if param_table_len > 8 then mult_num size param.(8) else num_zero;
          num_shift_3 = if param_table_len > 9 then mult_num size param.(9) else num_zero;
          denom_shift_1 = if param_table_len > 10 then mult_num size param.(10) else num_zero;
          denom_shift_2 = if param_table_len > 11 then mult_num size param.(11) else num_zero;
          super_shift_1 = if param_table_len > 12 then mult_num size param.(12) else num_zero;
          super_shift_2 = if param_table_len > 13 then mult_num size param.(13) else num_zero;
          super_shift_3 = if param_table_len > 14 then mult_num size param.(14) else num_zero;
          sub_shift_1 = if param_table_len > 15 then mult_num size param.(15) else num_zero;
          sub_shift_2 = if param_table_len > 16 then mult_num size param.(16) else num_zero;
          super_drop = if param_table_len > 17 then mult_num size param.(17) else num_zero;
          sub_drop = if param_table_len > 18 then mult_num size param.(18) else num_zero;
          delim_1 = if param_table_len > 19 then mult_num size param.(19) else num_zero;
          delim_2 = if param_table_len > 20 then mult_num size param.(20) else num_zero;
          axis_height = if param_table_len > 21 then mult_num size param.(21) else num_zero;
          rule_thickness = if param_table_len > 7 then mult_num size param.(7) else num_zero;
          big_op_spacing_1 = if param_table_len > 8 then mult_num size param.(8) else num_zero;
          big_op_spacing_2 = if param_table_len > 9 then mult_num size param.(9) else num_zero;
          big_op_spacing_3 = if param_table_len > 10 then mult_num size param.(10) else num_zero;
          big_op_spacing_4 = if param_table_len > 11 then mult_num size param.(11) else num_zero;
          big_op_spacing_5 = if param_table_len > 12 then mult_num size param.(12) else num_zero;
        };
      ff_font = Some ff_font;
    }

(*-----------------------------------------------------------------------*)
